home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / bits.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.9 KB  |  288 lines
  1. (herald (assembler bits t 0)
  2.         (env t (assembler as_open) 
  3.                (assembler fg) 
  4.                (assembler ib) 
  5.                (assembler mark)))
  6.  
  7. ;;; Copyright (c) 1985 Yale University
  8. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  9. ;;; This material was developed by the T Project at the Yale University Computer 
  10. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  11. ;;; and to use it for any purpose is granted, subject to the following restric-
  12. ;;; tions and understandings.
  13. ;;; 1. Any copy made of this software must include this copyright notice in full.
  14. ;;; 2. Users of this software agree to make their best efforts (a) to return
  15. ;;;    to the T Project at Yale any improvements or extensions that they make,
  16. ;;;    so that these may be included in future releases; and (b) to inform
  17. ;;;    the T Project of noteworthy uses of this software.
  18. ;;; 3. All materials developed as a consequence of the use of this software
  19. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  20. ;;;    of acknowledging credit in academic research.
  21. ;;; 4. Yale has made no warrantee or representation that the operation of
  22. ;;;    this software will be error-free, and Yale is under no obligation to
  23. ;;;    provide any services, by way of maintenance, update, or otherwise.
  24. ;;; 5. In conjunction with products arising from the use of this material,
  25. ;;;    there shall be no use of the name of the Yale University nor of any
  26. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  27. ;;;    without prior written consent from Yale in each case.
  28. ;;;
  29.  
  30. ;;; Output bits; also checks to make sure address line up.
  31. ;;; Keeping track of the address is vestigial, it should be flushed
  32.  
  33. (define (bits ibv size machine)
  34.   (let ((ibv-length (vector-length ibv)))
  35.     (let ((bits (cons-bits size machine)))
  36.       (do ((i 0 (fx+ i 1))
  37.            (addr 0 (bits-ib bits addr (vref ibv i))))
  38.           ((fx>= i ibv-length)
  39.            (return bits (bytev-length (bits-bv bits))))))))
  40.  
  41. (define (bits-ib bits start-addr ib)
  42.   (let ((a (ib-align ib)))
  43.     (let ((start-addr 
  44.            (cond ((and a (fx> a 0))
  45.                   (write-bits bits a 0)
  46.                   (fx+ start-addr a))
  47.                  (else 
  48.                   start-addr))))
  49.        (if (fxn= start-addr (ib-address ib))
  50.            (error "misaligned in bits"))
  51.        (iterate loop ((i's (ib-instructions ib))
  52.                       (addr start-addr))
  53.           (cond ((null? i's) addr)
  54.                 (else
  55.                  (let ((new-addr (bits-fg bits addr (car i's))))
  56.                     ;; really just for debugging & listings
  57.                     ;; (set (fg-size (car i's)) (fx- new-addr addr))
  58.                     (loop (cdr i's) new-addr))))))))
  59.  
  60. ;;; First because maybe defined integrable.
  61. (define (bits-field bits sign width vop voc1 vars vals)
  62.     (let ((value (get-value vop voc1 vars vals)))
  63.       ;; could check that width is enough for sign&value.
  64.       (write-bits bits width value)))
  65.                                                           
  66. (define (bits-fg bits start-addr fg)
  67.   (let* ((fgt (fg-type fg))
  68.          (vars (fg-vars fg))
  69.          (vals (fg-type-vals fgt)))
  70.     (iterate loop ((ops (fg-type-ops fgt))
  71.                    (addr start-addr))
  72.       (cond ((null? ops) addr)
  73.             (else
  74.              (xselect (car ops)
  75.                ((wop/fix)
  76.                 (destructure (((#f sign width vop voc1 . ops) ops))
  77.                   (bits-field bits sign width vop voc1 vars vals)
  78.                   (loop ops (fx+ addr width))))
  79.                ((wop/@fix)
  80.                 (destructure (((#f sign width-i vop voc1 . ops) ops))
  81.                   (let ((width (vref vars width-i)))
  82.                      (bits-field bits sign width vop voc1 vars vals)
  83.                      (loop ops (fx+ addr width)))))
  84.                ((wop/proc)
  85.                 (destructure (((#f sign cw-i proc-i vop voc1 . ops) ops))
  86.                   (let ((width (vref vars cw-i)))
  87.                      (bits-field bits sign width vop voc1 vars vals)
  88.                      (loop ops (fx+ addr width)))))
  89.                
  90.                ((wop/var)
  91.                 (destructure (((#f sign cw-i opt-i vop voc1 . ops) ops))
  92.                   (let ((width (vref vars cw-i)))
  93.                      (bits-field bits sign width vop voc1 vars vals)
  94.                      (loop ops (fx+ addr width)))))
  95.  
  96.                ((wop/depending-on)
  97.                 (destructure (((#f sdf#-i sdf-i mark-i fge-i . ops) ops))
  98.                   (let* ((sdf (vref vars sdf-i))
  99.                          (width (sdf-width sdf)))
  100.                     (let ((fgs ((vref vals fge-i) vars)))
  101.                       (if (list? fgs) 
  102.                           (walk (lambda (fg) (bits-fg bits 0 fg)) fgs)
  103.                           (bits-fg bits 0 fgs)))
  104.                     (loop ops (fx+ addr width)))))
  105.                
  106.                ((wop/subfield-ic)
  107.                 (destructure (((#f sf-i vop voc1 . ops) ops))
  108.                   (let ((new-addr (bits-fg bits addr (vref vars sf-i))))
  109.                     (loop ops new-addr))))
  110.                
  111.                ((wop/mark)
  112.                 (destructure (((#f mark-i . ops) ops))
  113.                   (loop ops addr)))
  114.                ))))))
  115.  
  116. ;;;;  The real grubby bits stuff
  117.  
  118. (define-structure-type bits
  119.   clump-size clump-writer clumps clumps-i clump-remaining bv bvpos)
  120.  
  121. (let ((b (stype-master bits-stype)))
  122.   (set (bits-clumps-i b) 0)
  123.   (set (bits-bvpos b) 0)
  124.   )
  125.  
  126. (define (cons-bits bit-size machine)
  127.   (let ((b (make-bits))
  128.         (size (fx/ (fixnum-ceiling bit-size 32) 8)))
  129.  
  130.     ;; these two cached from machine guy for convenience
  131.     (set (bits-clump-size b)      (machine-clump-size machine))
  132.     (set (bits-clump-writer b)    (machine-clump-writer machine))
  133.  
  134.     (set (bits-clump-remaining b) (bits-clump-size b))
  135.     (set (bits-bv b)              (make-bytev size))
  136.     (set (bits-clumps b)          (make-vector (machine-maximum-clumps machine)))
  137.     b))
  138.  
  139. (define-integrable (hacked-bf value start count)
  140.   (cond ((fixnum? value)
  141.          (fixnum-logand (fixnum-lognot (fixnum-ashl -1 count))
  142.                         (fixnum-ashr value start)))
  143.         (else
  144.          (bignum-bit-field-fixnum value start count))))
  145.  
  146. ;;; Should be just BIT-FIELD, when it is finally in T.  This is 
  147. ;;; used by various FGs
  148.  
  149. (define hacked-bit-field hacked-bf)
  150.  
  151. ;;; Hacking bits is gross in T.
  152.  
  153. (define (bignum-bit-field-fixnum v s c)
  154.   (let ((result (bignum-bit-field v s c)))
  155.     (if (fixnum? result) 
  156.         result
  157.         (error "tas expects a fixnum~%  (bignum-bit-field ~s ~s ~s)" v s c))))
  158.                                                                        
  159. ;;; Fill clumps until on an even clump boundry, then dump clumps.
  160. ;;; First clump is high bits.
  161.  
  162. (define (write-bits bits width value)
  163.   (cond ((and (fx> width 32) (fx= value 0))  ; ???? this is completely wrong
  164.          (write-bits-space bits width))
  165.         (else
  166.          (write-bits-1 bits width value))))
  167.  
  168. ;;; (put here because of define-integrable)
  169.  
  170. (define-integrable (write-clumps bits clumps-i)
  171.   (if (fx>= clumps-i (vector-length (bits-clumps bits)))
  172.       (error "(while writing bits) too many buffered clumps: ~s" clumps-i))
  173.   (let ((clumps (bits-clumps bits))
  174.         (bv (bits-bv bits))
  175.         (bvpos (bits-bvpos bits)))
  176.     (set (bits-bvpos bits) ((bits-clump-writer bits) clumps clumps-i bv bvpos))
  177.     (set (bits-clumps-i bits) 0)
  178.     (set (bits-clump-remaining bits) (bits-clump-size bits))
  179.     ))
  180.  
  181. (define (write-bits-1 bits width value)
  182.   (let ((clumps (bits-clumps bits))
  183.         (clumps-i (bits-clumps-i bits))
  184.         (c-rem (bits-clump-remaining bits))
  185.         (csize (bits-clump-size bits)))
  186.       (iterate make-clumps ((clumps-i clumps-i) (v-width width) (c-rem c-rem))
  187.            (cond ((fx< v-width c-rem)
  188.                   ;(format t "fits: ~s ~s ~%" v-width c-rem)
  189.                   (modify (vref clumps clumps-i)
  190.                           (lambda (c) (fixnum-logior (fixnum-ashl c v-width) 
  191.                                                      (hacked-bf value 0 v-width))))
  192.                   (set (bits-clumps-i bits) clumps-i)
  193.                   (set (bits-clump-remaining bits) (fx- c-rem v-width)))
  194.                  (else
  195.                   ;(format t "no fit: ~s ~s ~%" v-width c-rem)
  196.                   (let ((start-bit (fx- v-width c-rem)))
  197.                     (modify (vref clumps clumps-i)
  198.                             (lambda (c) 
  199.                                (fixnum-logior (fixnum-ashl c c-rem)
  200.                                               (hacked-bf value start-bit c-rem))))
  201.                     (cond ((fx> start-bit 0)
  202.                            ;(format t "looping - start-bit is ~s~%" start-bit)
  203.                            (make-clumps (fx+ clumps-i 1) start-bit csize))
  204.                           (else 
  205.                            (write-clumps bits clumps-i)))
  206.                     ))))))
  207.  
  208. ;;; put some amount of "space" out, clumps must be clear?
  209.  
  210. (define (write-bits-space bits count)
  211.   (let ((csize (bits-clump-size bits)))
  212.     (cond ((not (fx= (fixnum-remainder count csize) 0))
  213.            (error "(while writing bits) odd amount of bit space ~S" count))
  214.           ((fxn= (bits-clump-remaining bits) csize)
  215.            (error "(while writing bits) misaligned bit space - 1" count))
  216.           ((fxn= (bits-clumps-i bits) 0)
  217.            (error "(while writing bits) misaligned bit space - 2" count))
  218.           (else
  219.            (modify (bits-bvpos bits)
  220.                    (lambda (p) (fx+ p (fx/ count csize))))))))
  221.  
  222.  
  223. ;;; Flonum dismemberment.
  224.  
  225. ;;; Returns sign, and normalized mantissa and exponent  
  226. ;;; PRECISION is number of bits desired in the mantissa 
  227. ;;; EXCESS is the exponent excess
  228. ;;; HIDDEN-BIT-IS-1.? is true if the hidden bit preceeds the
  229. ;;;  binary point (it does in Apollo IEEE, does not on the VAX).
  230.  
  231. (define (normalized-float-parts flonum precision excess hidden-bit-is-1.?)
  232.     (cond ((fl= flonum 0.0)
  233.            (return 0 (%ash 1 (fx+ precision 1)) 0))
  234.           (else
  235.            (integer-decode-float
  236.             (proclaim float? flonum)
  237.             (lambda (m e)
  238.               (let* ((have (integer-length m))
  239.                      (need (fx- precision have))
  240.                      (normalized-m (%ash m need))
  241.                      (normalized-e (- (+ e 
  242.                                          precision 
  243.                                          excess
  244.                                          (if hidden-bit-is-1.? -1 0))
  245.                                        need)))
  246.                  (return (if (fl< flonum 0.0) 1 0) normalized-m normalized-e)
  247.                  ))))))
  248.  
  249.  
  250. ;;; Machine specfic clump writers.
  251.  
  252. ;;; These routine could be made into a single machine independent
  253. ;;; one that is parameterized with bits/byte, bytes/clump, clump order,
  254. ;;; bit order, and clump size.  This way seems simpler.
  255.  
  256. ;;; Write the bits in the clumps [0..clumps-i] into the byte vector 
  257. ;;; BV starting at BVPOS.  CLUMPS is a vector of fixnums, each fixnum 
  258. ;;; a clump, the number of bits in the clump depends on the machine.
  259. ;;; The choices are which way to look over the clumps (the most
  260. ;;; significant clump is index 0), which way to write the bits of
  261. ;;; a single clump, and how many bits of each clump to put into a byte 
  262. ;;; (this is usually 8), and whether low bits
  263.  
  264. ;;; Return the next unused position in BV which will be
  265. ;;; something like (+ BVPOS (* BYTES/CLUMP (+ CLUMPS-I 1)))
  266.  
  267. ;;; 1 byte/clump, 8 bits/byte, low clumps first, low bits first
  268. (define (vax/write-clumps clumps clumps-i bv bvpos)
  269.   (do ((i clumps-i (fx- i 1))
  270.        (bvpos bvpos (fx+ bvpos 1)))
  271.       ((fx< i 0) 0)
  272.     (set (bref bv bvpos) (vref clumps i))
  273.     (set (vref clumps i) 0))
  274.   (fx+ bvpos (fx+ 1 clumps-i)))
  275.  
  276. ;;; 2 bytes/clump, 8 bits/byte, high clumps first, high bits first
  277. (define (m68/write-clumps clumps clumps-i bv bvpos)
  278.   (do ((i 0 (fx+ i 1))
  279.        (bvpos bvpos (fx+ bvpos 2)))
  280.       ((fx> i clumps-i) 0)
  281.     (let ((c (vref clumps i)))
  282.        (set (bref bv bvpos) (fixnum-ashr c 8))
  283.        (set (bref bv (fx+ bvpos 1)) c))
  284.     (set (vref clumps i) 0))
  285.   (fx+ bvpos (fixnum-ashl (fx+ 1 clumps-i) 1)))
  286.  
  287.  
  288.